home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 501-525 / disk_503 / pcq / pcq12asc.lzh / Source / StanProcs.p < prev    next >
Text File  |  1991-06-10  |  21KB  |  848 lines
  1. External;
  2.  
  3. {
  4.     Stanprocs.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This routine implements the various standard procedures,
  8.     hence the name.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13.  
  14.     Procedure NextSymbol;
  15.         external;
  16.     Function Match(s : Symbols): Boolean;
  17.         external;
  18.     Procedure Error(s : string);
  19.         external;
  20.     Function Expression : TypePtr;
  21.         external;
  22.     Function ConExpr(VAR t : TypePtr): Integer;
  23.         external;
  24.     Function GetReference : ExprPtr;
  25.         External;
  26.     Procedure EvalAddress(Expr : ExprPtr; ToReg : Regs);
  27.         External;
  28.     Function SimpleReference(Expr : ExprPtr) : Boolean;
  29.         External;
  30.     Procedure FreeAllRegisters;
  31.         External;
  32.     Procedure MarkRegister(Reg : Regs);
  33.         External;
  34.     Procedure Optimize(Expr : ExprPtr);
  35.         External;
  36.     Function TypeCmp(t1, t2 : TypePtr): Boolean;
  37.         external;
  38.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  39.         external;
  40.     Function LoadAddress : TypePtr;
  41.         external;
  42.     Procedure Mismatch;
  43.         external;
  44.     Procedure UsingSmallStartup;
  45.         External;
  46.     Procedure NeedLeftParent;
  47.         external;
  48.     Procedure NeedRightParent;
  49.         external;
  50.     Procedure NeedNumber;
  51.         external;
  52.     Function FindID(s : string) : IDPtr;
  53.         external;
  54.     Function FindWithField(s : String) : IDPtr;
  55.         External;
  56.     Procedure SaveStack(TP : TypePtr);
  57.         external;
  58.     Procedure SaveVal(ID : IDPtr);
  59.         external;
  60.     Procedure ns;
  61.         external;
  62.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  63.         external;
  64.     Function NumberType(t : TypePtr): Boolean;
  65.         external;
  66.     Procedure PushLongD0;
  67.         external;
  68.     Procedure PushWordD0;
  69.         external;
  70.     Procedure PopLongD1;
  71.         external;
  72.     Procedure PopStackSpace(amount : Integer);
  73.         External;
  74.     Procedure PushLongA0;
  75.         External;
  76.     Function Suffix(size : Integer) : Char;
  77.         External;
  78.     Procedure AddConstant(Amount : Integer; ToReg : Regs; Size : Byte);
  79.         External;
  80.     Function PromoteTypeA(Expr : ExprPtr; TP : TypePtr) : ExprPtr;
  81.         External;
  82.     Function ExpressionTree : ExprPtr;
  83.         External;
  84.     Procedure Evaluate(Expr : ExprPtr; ToReg : Regs);
  85.         External;
  86.     Procedure Out_Operation0(op : OpCodes);
  87.         External;
  88.     Procedure Out_Operation1(op : OpCodes; Size : Byte;
  89.                     EA : EAModes; Reg : Regs);
  90.         External;
  91.     Procedure Out_Operation2(op : OpCodes; Size : Byte;
  92.                     SrcEA : EAModes; SrcReg : Regs;
  93.                     DestEA : EAModes; DestReg : Regs);
  94.         External;
  95.     Procedure Out_Extension(Ext : Integer);
  96.         External;
  97.     Procedure WriteSimpleDest(Expr : ExprPtr; op : OpCodes; Size : Byte;
  98.                 SrcEA : EAModes; SrcReg : Regs;
  99.                 SExt1, SExt2 : Integer);
  100.         External;
  101.  
  102.  
  103.  
  104. Procedure CallCheckIO;
  105. begin
  106.     Out_Operation1(op_JSR,3,ea_String,a7);
  107.     Out_Extension(Integer("_p%CheckIO"));
  108. end;
  109.  
  110. Procedure CallWrite(TP : TypePtr);
  111.  
  112. {
  113.     This routine calls the appropriate library routine to write
  114. vartype to a text file.
  115. }
  116.  
  117. var
  118.     ElementType    : TypePtr;
  119. begin
  120.     if TypeCmp(TP, RealType) then begin
  121.     Out_Operation1(op_JSR,3,ea_String,a7);
  122.     Out_Extension(Integer("_p%WriteReal"));
  123.     end else if NumberType(TP) then begin
  124.     PromoteType(TP, IntType, 0);
  125.     Out_Operation1(op_JSR,3,ea_String,a7);
  126.     Out_Extension(Integer("_p%WriteInt"));
  127.     end else if TypeCmp(TP, CharType) then begin
  128.     Out_Operation1(op_JSR,3,ea_String,a7);
  129.     Out_Extension(Integer("_p%WriteChar"));
  130.     end else if TypeCmp(TP, BoolType) then begin
  131.     Out_Operation1(op_JSR,3,ea_String,a7);
  132.     Out_Extension(Integer("_p%WriteBool"));
  133.     end else if TP^.Object = ob_array then begin
  134.     ElementType := TP^.SubType;
  135.     if TypeCmp(ElementType, CharType) then begin
  136.         Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Register,d3);
  137.         Out_Extension(Succ(TP^.Upper - TP^.Lower));
  138.         Out_Operation1(op_JSR,3,ea_String,a7);
  139.         Out_Extension(Integer("_p%WriteCharray"));
  140.     end else
  141.         Error("Write() can only write arrays of char");
  142.     end else if TP = StringType then begin
  143.     Out_Operation1(op_JSR,3,ea_String,a7);
  144.     Out_Extension(Integer("_p%WriteString"));
  145.     end else
  146.     Error("can't write that type to text file");
  147.     if IOCheck then
  148.     CallCheckIO;
  149.     MathLoaded := False;
  150. end;
  151.  
  152. Procedure FileWrite(TP : TypePtr);
  153.  
  154. {
  155.     This routine writes a variable to a File of TP
  156. }
  157.  
  158. begin
  159.     Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Register,d3);
  160.     Out_Extension(TP^.Size);
  161.     Out_Operation1(op_JSR,3,ea_String,a7);
  162.     Out_Extension(Integer("_p%WriteArb"));
  163.     if IOCheck then
  164.     CallCheckIO;
  165.     MathLoaded := False;
  166. end;
  167.  
  168. Procedure DoWrite(ID : IDPtr);
  169.  
  170. {
  171.     This routine handles all aspects of the write and writeln
  172. statements.
  173. }
  174.  
  175. var
  176.     FileType    : TypePtr; { file type if there is one }
  177.     ExprType    : TypePtr; { current element type }
  178.     Pushed    : Boolean; { have pushed the file handle on stack }
  179.     Width    : Integer; { constant field width }
  180.     WidType     : TypePtr; { type of the above }
  181. begin
  182.     if SmallInitialize then
  183.     UsingSmallStartup;
  184.     if Match(LeftParent1) then begin
  185.     FileType := Expression();
  186.     Pushed := True;
  187.     if FileType^.Object = ob_file then
  188.         PushLongD0
  189.     else begin
  190.         Out_Operation1(op_PUSH,4,ea_String,a7);
  191.         Out_Extension(Integer("#_Output"));
  192.         StackLoad := StackLoad + 4;
  193.         if Match(colon1) then begin
  194.         PushLongD0;
  195.         WidType := Expression();
  196.         if not TypeCheck(IntType, WidType) then
  197.             NeedNumber
  198.         else
  199.             PromoteType(WidType,ShortType,0);
  200.         PopLongD1;
  201.         PushWordD0;
  202.         Out_Operation2(op_MOVE,4,ea_Register,d1,ea_Register,d0);
  203.         end else begin
  204.         Out_Operation1(op_PUSH,2,ea_Constant,a7);
  205.         Out_Extension(0);
  206.         StackLoad := StackLoad + 2;
  207.         end;
  208.         if TypeCmp(FileType, RealType) then begin
  209.         if Match(colon1) then begin
  210.             PushLongD0;
  211.             WidType := Expression();
  212.             if not TypeCheck(IntType, WidType) then
  213.             NeedNumber
  214.             else
  215.             PromoteType(WidType,ShortType,0);
  216.             PopLongD1;
  217.             PushWordD0;
  218.             Out_Operation2(op_MOVE,4,ea_Register,d1,ea_Register,d0);
  219.         end else begin
  220.             Out_Operation1(op_PUSH,2,ea_Constant,a7);
  221.             Out_Extension(2);
  222.             StackLoad := StackLoad + 2;
  223.         end;
  224.         end;
  225.         CallWrite(FileType);
  226.         if TypeCmp(FileType, RealType) then
  227.         PopStackSpace(4)
  228.         else
  229.         PopStackSpace(2);
  230.         FileType := TextType;
  231.     end;
  232.     while not Match(RightParent1) do begin
  233.         if not Match(Comma1) then
  234.         Error("expecting , or )");
  235.         ExprType := Expression();
  236.         if FileType = TextType then begin
  237.         if Match(Colon1) then begin
  238.             PushLongD0;
  239.             WidType := Expression();
  240.             if not TypeCheck(IntType, WidType) then
  241.             NeedNumber
  242.             else
  243.             PromoteType(WidType,ShortType,0);
  244.             PopLongD1;
  245.             PushWordD0;
  246.             Out_Operation2(op_MOVE,4,ea_Register,d1,ea_Register,d0);
  247.         end else begin
  248.             Out_Operation1(op_PUSH,2,ea_Constant,a7);
  249.             Out_Extension(0);
  250.             StackLoad := StackLoad + 2;
  251.         end;
  252.         if TypeCmp(ExprType, RealType) then begin
  253.             if Match(colon1) then begin
  254.             PushLongD0;
  255.             WidType := Expression();
  256.             if not TypeCheck(IntType, WidType) then
  257.                 NeedNumber
  258.             else
  259.                 PromoteType(WidType,ShortType,0);
  260.             PopLongD1;
  261.             PushWordD0;
  262.             Out_Operation2(op_MOVE,4,ea_Register,d1,ea_Register,d0);
  263.             end else begin
  264.             Out_Operation1(op_PUSH,2,ea_Constant,a7);
  265.             Out_Extension(2);
  266.             StackLoad := StackLoad + 2;
  267.             end;
  268.         end;
  269.         CallWrite(ExprType);
  270.         if TypeCmp(ExprType, RealType) then
  271.             PopStackSpace(4)
  272.         else
  273.             PopStackSpace(2);
  274.         end else begin
  275.         if TypeCmp(FileType^.SubType, ExprType) then
  276.             FileWrite(ExprType)
  277.         else
  278.             Mismatch;
  279.         end;
  280.     end;
  281.     end else begin
  282.     FileType := TextType;
  283.     Pushed := False;
  284.     if ID^.Offset = 1 then
  285.         error("'write' requires arguments.");
  286.     end;
  287.     if ID^.Offset = 2 then begin
  288.     if FileType = TextType then begin
  289.         if Pushed then begin
  290.         Out_Operation1(op_JSR,3,ea_String,a7);
  291.         Out_Extension(Integer("_p%WriteLn"));
  292.         end else begin
  293.         Out_Operation1(op_PUSH,4,ea_String,a7);
  294.         Out_Extension(Integer("#_Output"));
  295.         Out_Operation1(op_JSR,3,ea_String,a7);
  296.         Out_Extension(Integer("_p%WriteLn"));
  297.         AddConstant(4, a7, 4);
  298.         end;
  299.         if IOCheck then
  300.         CallCheckIO;
  301.     end else
  302.        error("Writeln is only for text files");
  303.     end;
  304.     if Pushed then
  305.     PopStackSpace(4);
  306. end;
  307.  
  308. Procedure CallRead(TP : TypePtr);
  309.  
  310. {
  311.     This routine calls the appropriate library routines to read
  312. the vartype from a text file.
  313. }
  314.  
  315. begin
  316.     if TypeCmp(TP, CharType) then begin
  317.     Out_Operation1(op_JSR,3,ea_String,a7);
  318.     Out_Extension(Integer("_p%ReadChar"));
  319.     end else if TypeCmp(TP, IntType) then begin
  320.     Out_Operation1(op_JSR,3,ea_String,a7);
  321.     Out_Extension(Integer("_p%ReadInt"));
  322.     Out_Operation2(op_MOVE,4,ea_Register,d0,ea_Indirect,a0);
  323.     end else if TypeCmp(TP, ShortType) then begin
  324.     Out_Operation1(op_JSR,3,ea_String,a7);
  325.     Out_Extension(Integer("_p%ReadInt"));
  326.     Out_Operation2(op_MOVE,2,ea_Register,d0,ea_Indirect,a0);
  327.     end else if TypeCmp(TP, ByteType) then begin
  328.     Out_Operation1(op_JSR,3,ea_String,a7);
  329.     Out_Extension(Integer("_p%ReadInt"));
  330.     Out_Operation2(op_MOVE,1,ea_Register,d0,ea_Indirect,a0);
  331.     end else if TypeCmp(TP, RealType) then begin
  332.     Out_Operation1(op_JSR,3,ea_String,a7);
  333.     Out_Extension(Integer("_p%ReadReal"));
  334.     end else if TP^.Object = ob_array then begin
  335.     if TypeCmp(TP^.SubType, chartype) then begin
  336.         Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Register,d3);
  337.         Out_Extension(Succ(TP^.Upper - TP^.Lower));
  338.         Out_Operation1(op_JSR,3,ea_String,a7);
  339.         Out_Extension(Integer("_p%ReadCharray"));
  340.     end else
  341.         Error("can only read character arrays");
  342.     end else if TP = StringType then begin
  343.     Out_Operation1(op_JSR,3,ea_String,a7);
  344.     Out_Extension(Integer("_p%ReadString"));
  345.     end else
  346.     Error("cannot read that type from a text file");
  347.     if IOCheck then
  348.     CallCheckIO;
  349.     MathLoaded := False; { Overwritten by DOSBase }
  350. end;
  351.  
  352. Procedure DoRead(ID : IDPtr);
  353.  
  354. {
  355.     This handles the read statement.  Note that read(f, var) from a
  356. non-text file really does end up being var := f^; get(f).  Same
  357. goes for text files, but it's all handled within the library.
  358.     Note the difference between this and dowrite(),
  359. specifically the use of expression() up there and loadaddress()
  360. here.
  361. }
  362.  
  363. var
  364.     FileType,
  365.     VarType    : TypePtr;
  366.     Pushed    : Boolean;
  367. begin
  368.     if SmallInitialize then
  369.     UsingSmallStartup;
  370.     if Match(LeftParent1) then begin
  371.     FileType := LoadAddress();
  372.     Pushed := True;
  373.     if FileType^.Object = ob_file then
  374.         PushLongA0
  375.     else begin
  376.         Out_Operation1(op_PUSH,4,ea_String,a7);
  377.         Out_Extension(Integer("#_Input"));
  378.         StackLoad := StackLoad + 4;
  379.         CallRead(FileType);
  380.         FileType := TextType;
  381.     end;
  382.     while not Match(RightParent1) do begin
  383.         if not Match(Comma1) then
  384.         Error("expecting , or )");
  385.         VarType := LoadAddress();
  386.         if FileType = TextType then
  387.         CallRead(VarType)
  388.         else begin
  389.         if TypeCmp(FileType^.SubType, VarType) then begin
  390.             Out_Operation1(op_JSR,3,ea_String,a7);
  391.             Out_Extension(Integer("_p%ReadArb"));
  392.         end else
  393.             Mismatch;
  394.         if IOCheck then
  395.             CallCheckIO;
  396.         end;
  397.     end;
  398.     end else begin
  399.     FileType := TextType;
  400.     Pushed := False;
  401.     if ID^.Offset = 3 then
  402.         error("'read' requires arguments.");
  403.     end;
  404.     if ID^.Offset = 4 then begin
  405.     if TypeCmp(FileType, TextType) then begin
  406.         if Pushed then begin
  407.         Out_Operation1(op_JSR,3,ea_String,a7);
  408.         Out_Extension(Integer("_p%ReadLn"));
  409.         end else begin
  410.         Out_Operation1(op_PUSH,4,ea_String,a7);
  411.         Out_Extension(Integer("#_Input"));
  412.         Out_Operation1(op_JSR,3,ea_String,a7);
  413.         Out_Extension(Integer("_p%ReadLn"));
  414.         AddConstant(4, a7, 4);
  415.         end;
  416.         if IOCheck then
  417.         CallCheckIO;
  418.     end else
  419.        error("Readln applies only to Text files");
  420.     end;
  421.     if Pushed then
  422.     PopStackSpace(4);
  423. end;
  424.  
  425. Procedure DoNew;
  426.  
  427. {
  428.     This just handles allocation of memory.
  429. }
  430.  
  431. var
  432.     Expr    : ExprPtr;
  433. begin
  434.     NeedLeftParent;
  435.     NextFreeExprNode := 0;
  436.     ConstantExpression := False;
  437.     Expr := GetReference;
  438.     Optimize(Expr);
  439.     if Expr^.EType^.Object <> ob_pointer then
  440.     Error("Expecting a pointer type")
  441.     else begin
  442.     Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Register,d0);
  443.     Out_Extension(Expr^.EType^.SubType^.Size);
  444.     Out_Operation1(op_JSR,3,ea_String,a7);
  445.     Out_Extension(Integer("_p%new"));
  446.  
  447.     if SimpleReference(Expr) then begin
  448.         WriteSimpleDest(Expr, op_MOVE,4,ea_Register,d0,0,0);
  449.     end else begin
  450.         FreeAllRegisters;
  451.         MarkRegister(d0);
  452.         EvalAddress(Expr, a0);
  453.         Out_Operation2(op_MOVE,4,ea_Register,d0,ea_Indirect,a0);
  454.     end;
  455.     end;
  456.     NeedRightParent;
  457.     MathLoaded := False;
  458.     if SmallInitialize then
  459.     UsingSmallStartup;
  460. end;
  461.  
  462. Procedure DoDispose;
  463.  
  464. {
  465.     This routine calls the library routine that frees memory.
  466. }
  467.  
  468. var
  469.     ExprType    : TypePtr;
  470. begin
  471.     NeedLeftParent;
  472.     ExprType := Expression();
  473.     if ExprType^.Object <> ob_pointer then
  474.     Error("Expecting a pointer type")
  475.     else begin
  476.     Out_Operation1(op_JSR,3,ea_String,a7);
  477.     Out_Extension(Integer("_p%dispose"));
  478.     end;
  479.     NeedRightParent;
  480.     MathLoaded := False;
  481.     if SmallInitialize then
  482.     UsingSmallStartup;
  483. end;
  484.  
  485. Procedure DoClose;
  486.  
  487. {
  488.     Closes a file.  The difference between this and a normal
  489. DOS close is that this routine must un-link the file from the
  490. program's open file list.
  491. }
  492.  
  493. var
  494.     ExprType    : TypePtr;
  495. begin
  496.     NeedLeftParent;
  497.     ExprType := LoadAddress();
  498.     if ExprType^.Object <> ob_file then
  499.     Error("Expecting a file type")
  500.     else begin
  501.     Out_Operation1(op_JSR,3,ea_String,a7);
  502.     Out_Extension(Integer("_p%Close"));
  503.     end;
  504.     if IOCheck then
  505.     CallCheckIO;
  506.     NeedRightParent;
  507.     MathLoaded := False;
  508.     if SmallInitialize then
  509.     UsingSmallStartup;
  510. end;
  511.  
  512. Procedure DoGet;
  513.  
  514. {
  515.     This implements get.
  516. }
  517.  
  518. var
  519.     ExprType    : TypePtr;
  520. begin
  521.     NeedLeftParent;
  522.     ExprType := LoadAddress();
  523.     if ExprType^.Object <> ob_file then
  524.     Error("Expecting a file type")
  525.     else begin
  526.     Out_Operation1(op_JSR,3,ea_String,a7);
  527.     Out_Extension(Integer("_p%Get"));
  528.     end;
  529.     if IOCheck then
  530.     CallCheckIO;
  531.     NeedRightParent;
  532.     MathLoaded := False;
  533.     if SmallInitialize then
  534.     UsingSmallStartup;
  535. end;
  536.  
  537. Procedure DoPut;
  538.  
  539. {
  540.     This just implements put.  The real guts of these two
  541. routines is in the runtime library.
  542. }
  543.  
  544. var
  545.     ExprType    : TypePtr;
  546. begin
  547.     NeedLeftParent;
  548.     ExprType := LoadAddress();
  549.     if ExprType^.Object <> ob_file then
  550.     Error("Expecting a file type")
  551.     else begin
  552.     Out_Operation1(op_JSR,3,ea_String,a7);
  553.     Out_Extension(Integer("_p%Put"));
  554.     end;
  555.     if IOCheck then
  556.     CallCheckIO;
  557.     NeedRightParent;
  558.     MathLoaded := False;
  559.     if SmallInitialize then
  560.     UsingSmallStartup;
  561. end;
  562.  
  563. Procedure DoIncDec(op : OpCodes);
  564.  
  565. {
  566.     This takes care of Inc.
  567. }
  568.  
  569. var
  570.     Dest    : ExprPtr;
  571.     Delta    : Integer;
  572.     Expr    : ExprPtr;
  573.     IsSimple    : Boolean;
  574.     DSize    : Short;
  575.     Shifts    : Short;
  576. begin
  577.     NeedLeftParent;
  578.     NextFreeExprNode := 0;
  579.     FreeAllRegisters;
  580.     Dest := GetReference;
  581.     Optimize(Dest);
  582.  
  583.     with Dest^.EType^ do begin
  584.     if Object = ob_Ordinal then begin
  585.         Delta := 1;
  586.         DSize := Size;
  587.     end else if Object = ob_pointer then begin
  588.         Delta := SubType^.Size;
  589.         DSize := Size;
  590.     end else begin
  591.         Error("Expecting an ordinal or pointer type");
  592.         DSize := 1;
  593.         Delta := 1;
  594.     end;
  595.     end;
  596.  
  597.     if match(comma1) then begin
  598.     Expr := ExpressionTree;
  599.     if TypeCheck(Expr^.EType, IntType) then begin
  600.         case DSize of
  601.           2 : Expr := PromoteTypeA(Expr,ShortType);
  602.           4 : Expr := PromoteTypeA(Expr,IntType);
  603.         end;
  604.         Optimize(Expr);
  605.     end else
  606.         MisMatch;
  607.     end else
  608.     Expr := Nil;
  609.  
  610.     NeedRightParent;
  611.  
  612.     IsSimple := SimpleReference(Dest);
  613.  
  614.     if not IsSimple then
  615.     EvalAddress(Dest,a0);
  616.  
  617.     if (Expr = Nil) or (Expr^.Kind = Const1) then begin
  618.     if Expr <> Nil then
  619.         Delta := Expr^.Value * Delta;
  620.  
  621.     if Delta = 0 then
  622.         return;
  623.  
  624.     if (Delta < 0) and (Delta >= -8) then begin
  625.         Delta := -Delta;
  626.         if Op = op_SUB then
  627.         Op := op_ADD
  628.         else
  629.         Op := op_SUB;
  630.     end;
  631.  
  632.     if (Abs(Delta) <= 127) and (Abs(Delta) > 8) then begin
  633.         Out_Operation2(op_MOVEQ,3,ea_Constant,a7,ea_Register,d0);
  634.         Out_Extension(Delta);
  635.         if IsSimple then
  636.         WriteSimpleDest(Dest, Op, DSize, ea_Register,d0,0,0)
  637.         else
  638.         Out_Operation2(Op, DSize, ea_Register,d0,
  639.                             ea_Indirect,a0);
  640.     end else if IsSimple then
  641.         WriteSimpleDest(Dest,Op,DSize,ea_Constant,a7,Delta,0)
  642.     else begin
  643.         Out_Operation2(Op,DSize, ea_Constant,a7,ea_Indirect,a0);
  644.         Out_Extension(Delta);
  645.     end;
  646.     end else begin { not a constant increment }
  647.     if Expr^.EType^.Size = 1 then begin
  648.         Expr := PromoteTypeA(Expr,ShortType);
  649.         Optimize(Expr);
  650.     end;
  651.     Evaluate(Expr, d0);
  652.     case Delta of
  653.          1 : Shifts := 0;
  654.          2 : Shifts := 1;
  655.          4 : Shifts := 2;
  656.          8 : Shifts := 3;
  657.         16 : Shifts := 4;
  658.         32 : Shifts := 5;
  659.         64 : Shifts := 6;
  660.        128 : Shifts := 7;
  661.        256 : Shifts := 8;
  662.        512 : Shifts := 9;
  663.       1024 : Shifts := 10;
  664.       2048 : Shifts := 11;
  665.       4096 : Shifts := 12;
  666.       8192 : Shifts := 13;
  667.      16384 : Shifts := 14;
  668.      32768 : Shifts := 15;
  669.      65536 : Shifts := 16;
  670.     else begin
  671.              Out_Operation2(op_MULS,3,ea_Constant,a7,ea_Register,d0);
  672.          Out_Extension(Delta);
  673.          Shifts := -1;
  674.          end;
  675.     end;
  676.  
  677.     if Shifts > 7 then begin
  678.         Out_Operation2(op_MOVEQ,3,ea_Constant,a7,ea_Register,d1);
  679.         Out_Extension(Shifts);
  680.         Out_Operation2(op_LSL,DSize,ea_Register,d1,ea_Register,d0);
  681.     end else if Shifts > 0 then begin
  682.         Out_Operation2(op_LSL,DSize,ea_Constant,a7,ea_Register,d0);
  683.         Out_Extension(Shifts);
  684.     end;
  685.  
  686.     if IsSimple then
  687.         WriteSimpleDest(Dest,Op,DSize,ea_Register,d0,0,0)
  688.     else
  689.         Out_Operation2(Op, DSize, ea_Register,d0,ea_Indirect,a0);
  690.     end;
  691. end;
  692.  
  693. Procedure DoExit;
  694.  
  695. {
  696.     Just calls the routine that allows the graceful shut-down
  697. of the program.
  698. }
  699.  
  700. var
  701.     Expr : ExprPtr;
  702. begin
  703.     if Match(LeftParent1) then begin
  704.     NextFreeExprNode := 0;
  705.     ConstantExpression := False;
  706.     Expr := ExpressionTree;
  707.     Optimize(Expr);
  708.     if TypeCheck(Expr^.EType, IntType) then
  709.         Expr := PromoteTypeA(Expr, IntType)
  710.     else
  711.         Error("Expecting an integer argument");
  712.     FreeAllRegisters;
  713.     Evaluate(Expr,d0);
  714.     NextFreeExprNode := 0;
  715.     NeedRightParent;
  716.     end else begin
  717.     Out_Operation2(op_MOVEQ,3,ea_Constant,a7,ea_Register,d0);
  718.     Out_Extension(0);
  719.     end;
  720.     Out_Operation1(op_JSR,3,ea_String,a7);
  721.     Out_Extension(Integer("_p%exit"));
  722.     MathLoaded := False;
  723. end;
  724.  
  725. Procedure DoTrap;
  726.  
  727. {
  728.     This is just for debugging a program.  Use some trap, and
  729. your debugger will stop at that statement.
  730. }
  731.  
  732. var
  733.     ExprType  : TypePtr;
  734.     TrapNum   : Integer;
  735. begin
  736.     NeedLeftParent;
  737.     TrapNum := ConExpr(ExprType);
  738.     Out_Operation1(op_TRAP,3,ea_Constant,a7);
  739.     Out_Extension(TrapNum);
  740.     NeedRightParent;
  741. end;
  742.  
  743.  
  744. Procedure DoFileOpen(Which : Integer);
  745. var
  746.     FName : ExprPtr;
  747.     FVar  : ExprPtr;
  748.     Buffer: ExprPtr;
  749.     RecSize : Integer;
  750. begin
  751.     NeedLeftParent;
  752.     NextFreeExprNode := 0;
  753.     ConstantExpression := False;
  754.  
  755.     FVar := GetReference;
  756.     if FVar^.EType^.Object = ob_file then begin
  757.     Optimize(FVar);
  758.     RecSize := FVar^.EType^.SubType^.Size;
  759.     end else begin
  760.     Error("Expecting a file type");
  761.     RecSize := 1;
  762.     end;
  763.  
  764.     if not match(comma1) then
  765.     Error("Missing comma");
  766.  
  767.     FName := ExpressionTree;
  768.     if TypeCheck(StringType,FName^.EType) then begin
  769.     Optimize(FName);
  770.     FreeAllRegisters;
  771.     Evaluate(FName, d0);
  772.     Out_Operation1(op_PUSH,4,ea_Register,d0);
  773.     StackLoad := StackLoad + 4;
  774.     end else
  775.     Mismatch;
  776.  
  777.     FreeAllRegisters;
  778.     if FVar^.EType^.Object = ob_file then
  779.     EvalAddress(FVar, a0);
  780.  
  781.     Out_Operation2(op_MOVE,2,ea_Constant,a7,ea_Index,a0);
  782.  
  783.     if Which = 14 then        { reset - MODE_OLDFILE}
  784.     Out_Extension(1005)
  785.     else
  786.     Out_Extension(1006);    { rewrite - MODE_NEWFILE}
  787.     Out_Extension(30);        { ACCESS(a0) }
  788.  
  789.     if RecSize <= 127 then begin
  790.     Out_Operation2(op_MOVEQ,3,ea_Constant,a7,ea_Register,d0);
  791.     Out_Extension(RecSize);
  792.     Out_Operation2(op_MOVE,4,ea_Register,d0,ea_Index,a0);
  793.     end else begin
  794.     Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Index,a0);
  795.     Out_Extension(RecSize);
  796.     end;
  797.     Out_Extension(24);
  798.  
  799.     if match(comma1) then begin
  800.     Buffer := ExpressionTree;
  801.     if TypeCheck(Buffer^.EType,IntType) then begin
  802.         Optimize(Buffer);
  803.         Evaluate(Buffer,d0);
  804.         Out_Operation2(op_MOVE,4,ea_Register,d0,ea_Index,a0);
  805.     end else
  806.         Mismatch;
  807.     end else begin
  808.     Out_Operation2(op_MOVE,4,ea_Constant,a7,ea_Index,a0);
  809.     Out_Extension(128);
  810.     end;
  811.     Out_Extension(20);
  812.  
  813.     Out_Operation1(op_PUSH,4,ea_Register,a0);
  814.  
  815.     Out_Operation1(op_JSR,3,ea_String,a7);
  816.     Out_Extension(Integer("_p%OpenB"));
  817.  
  818.     AddConstant(8, a7, 4);
  819.     StackLoad := StackLoad - 4; { we only added for FName }
  820.     NeedRightParent;
  821. end;
  822.  
  823. Procedure StdProc(ProcID : IDPtr);
  824.  
  825. {
  826.     This routine sifts out the proper routine to call.
  827. }
  828.  
  829. begin
  830.     NextSymbol;
  831.     case ProcID^.Offset of
  832.       1,2 : DoWrite(ProcID);
  833.       3,4 : DoRead(ProcID);
  834.       5   : DoNew;
  835.       6   : DoDispose;
  836.       7   : DoClose;
  837.       8   : DoGet;
  838.       9   : DoExit;
  839.       10  : DoTrap;
  840.       11  : DoPut;
  841.       12  : DoIncDec(op_ADD);
  842.       13  : DoIncDec(op_SUB);
  843.       14,
  844.       15  : DoFileOpen(ProcID^.Offset);
  845.     end;
  846. end;
  847.  
  848.